COMMENT ⊗   VALID 00003 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	SUBR HEAP1D (ITG ARRAY AA INTEGER N)
 00004 00003	α PHASE TWO, TAKE 'EM OFF THE TOP & PROMOTE SUBORDINATES
 00006 ENDMK
⊗;
SUBR HEAP1D (ITG ARRAY AA; INTEGER N);
S⊂ "HEAPSORT"
	LABEL A1,A2,A3,A4,A5,A6,A7,   A9,A10,A11,A12;
	LABEL L0,L1,L2,L3,L4,L5;
	LABEL WHILE,DONE;
	DEFINE I="1",J="2",K="3",X="4",A="0",AJ="5";
α ALITTLE ADDRESS MODIFICATION;
	MOVE	AA;SOS;	HRRM	A5;	HRRM	A6;
	HRRM	A1;	HRRM	A7;
	HRRM	A2;	HRRM	A9;	HRRM	A10;
	HRRM	A3;	HRRM	A12;
	HRRM	A4;
	HRRM	L2;	HRRM	DONE;	AOS;HRRM A11;
α PHASE ONE, PUT 'EM UNDER THE HEAP & BIGGIES TRICKLE UP;
α	FOR K←2 STEP 1 UNTIL N DO
α	BEGIN
α		I←K;
α		X←A[I];
α		WHILE I>1 ∧ X>A[J←I%2] DO
α		BEGIN A[I]←A[J]  I←J END;
α		A[I]←X;
α	END;
		MOVEI	K,2;
	L0:	CAMLE	K,N;
		JRST	L3;
		MOVE	I,K;
	A1:	MOVE	X,A(I);
	L1:	MOVE	J,I;
		LSH	J,-1;
		JUMPE	J,L2;
	A2:	CAMG	X,A(J);
		JRST	L2;
	A3:	MOVE	A(J);
	A4:	MOVEM	A(I);
		MOVE	I,J;
		JRST	L1;
	L2:	MOVEM	X,A(I);
		AOJA	K,L0;
	L3:
α PHASE TWO, TAKE 'EM OFF THE TOP & PROMOTE SUBORDINATES;
α	FOR K←N STEP -1 UNTIL 2 DO
α	BEGIN
α		X←A[K] A[K]←A[1] I←1;
α		WHILE (J←2*I)<K DO
α		BEGIN
α			IF (J+1)<K ∧ A[J+1]>A[J] THEN J←J+1;
α			IF X≥A[J] THEN DONE ELSE
α			BEGIN A[I]←A[J] I←J END;
α		END;
α		A[I]←X;
α	END;

		MOVE	K,N;
		SUB	'17,['3000003];
	L4:	CAIGE	K,2;
		JRST @3('17);
α X←A[K] A[K]←A[1] I←1;
	A5:	MOVE	X,A(K);
		MOVEI	I,1;
	A6:	MOVE	A(I);
	A7:	MOVEM	A(K);
α WHILE (J←2*I)<K DO;
		MOVE	J,I;
	WHILE:	LSH	J,1;
		CAML	J,K;
		JRST	DONE;
α IF (J+1)<K ∧ A[J+1]>A[J] THEN J←J+1;
	A9:	MOVE	AJ,A(J);
		CAIG	K,1(J);
		JRST	L5;
	A11:	CAML	AJ,A+1(J);
		JRST	L5;
		AOS	J;
	A10:	MOVE	AJ,A(J);
α IF X≥A[J] THEN DONE ELSE
α BEGIN A[I]←A[J] I←J END;
	L5:	CAML	X,AJ;
		JRST	DONE;
	A12:	MOVEM	AJ,A(I);
		MOVE	I,J;
		JRST	WHILE;
	DONE:	MOVEM	X,A(I);
		SOJA	K,L4;
END "HEAPSORT";
END	"HEAP1D";